;;; Commentary:

;; ------------------------------------------------------------------------
;; Copyright (C) Oleg Sivokon (olegsivokon@gmail.com)

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;; ------------------------------------------------------------------------

;; This is formatting.el, an extension of Emacs Lisp format mini-language.
;; It borrows heavily from Common Lisp formatting mini-language, but does
;; not implement all features available in CL.

;; formatting is NOT part of GNU Emacs.

;;; Versions:
;;
;;    0.1.0 - Initial release.

;;; Usage:
;;  (cl-format "begin: %{%s = %d%^,%}; %* %% %c %
;;              %% %{%{%[%s%;<%s>%:(%s)%]%^.%},%} %/identity/"
;;             '(a 1 b 2 c 3) 42 ?\X '((0 a 1 b 2 c) (2 a 1 b 0 c)) 43)
;; =>
;; "begin: a = 1,b = 2,c = 3;  % X % a.<b>.(2).(c),(2).(a).<b>.c, 43"
;; See documentation of `cl-format' for more details


;;; Code:

(require 'cl)

(defun pp-directive-endp (c)
  (member c '(?c ?s ?d ?o ?x ?X ?e ?g ?%)))

(defun pp-non-whitep (c)
  (not (member c '(?\ ?\t ?\n ?\r))))

(defun pp-if-nil (spec)
  (position ?\% spec))

(defun pp-call-func (name arg)
  (princ (funcall (intern name) arg)))

(defun pp-condition (spec args)
  (let ((pos 0) (last 0) (fstring "% ")
        (at-choice 0) (choice (car args))
        must-print current seen-^ printed printing seen-default)
    (when (numberp choice) (setq args (cdr args)))
    (catch 't
      (while t
        (setq pos (1+ (or (position ?% spec :start pos) -1))
              current (aref spec pos)
              must-print (or (when (numberp choice)
                               (= choice at-choice))
                             (and (not printed) seen-default))
              printing (and must-print (not printed)))
        (when printing
          (princ (substring spec last (1- pos)))
          (unless (char-equal current ?\])
            (setq last pos pos (1+ pos))))
        (cond
         ((char-equal current ?^)
          (when printing
            (setq seen-^ t))
          (setf last (1+ pos)))
         ((char-equal current ?\n)
          (when printing
            (setq pos (position-if #'pp-non-whitep spec :start (1+ pos))
                  last pos
                  seen-^ nil)))
         ((char-equal current ?\])
          (incf pos)
          (throw 't nil))
         ((char-equal current ?\[)
          (when printing
            (multiple-value-bind (new-pos new-args)
                (pp-condition (substring spec pos) args)
              (setq pos (+ pos new-pos) args new-args last pos))))
         ((char-equal current ?\/)
          (if printing
              (let ((func-name
                     (substring spec pos
                                (position ?\/ spec :start pos))))
                (pp-call-func func-name (car args))
                (setq pos (+ 1 pos (length func-name))
                      last pos
                      seen-^ nil))
            (setf last (1+ pos))))
         ((char-equal current ?*)
          (if printing
              (setq args (cdr args) last (1+ last) seen-^ nil)
            (setf last (1+ pos))))
         ((char-equal current ?\{)
          (if printing
              (setq pos (+ pos (pp-list (substring spec pos) (car args)))
                    args (cdr args)
                    last pos)
            (setf last (1+ pos))))
         ((char-equal current ?\})
          (when printing
            (error "Unmatched list iteration termination directive")))
         ((char-equal current ?\;)
          (when seen-default
            (error "Choice operation shouldn't follow default"))
          (incf at-choice)
          (setf last (1+ pos))
          (when must-print
            (setq must-print nil printed t
                  printing nil last (1+ pos))))
         ((char-equal current ?\:)
          (when seen-default (error "Extra default choice"))
          (unless printed
            (if must-print
                (setq printed t seen-default t)
              (progn
                (when (numberp choice)
                  ;; we didn't use the choice option (it was out of range)
                  ;; so return it into the arguments list
                  (setq args (cons choice args)))
                (setq seen-default t))))
          (setf last (1+ pos) seen-^ nil))
         (t (when printing
              (unless args (error "Not enough argumens for condition"))
              (setf (aref fstring 1) current)
              (princ (format fstring (car args)))
              (setq args (cdr args) seen-^ nil))
            (setq last
                  (1+ (or (position-if #'pp-directive-endp
                                       spec :start (1- pos))
                          (1- pos))))))))
    (values pos args)))

(defun pp-list (spec args)
  (let ((pos 0) (last 0) (fstring "% ") current seen-^)
    (catch 't
      (while t
        (setq pos (1+ (or (position ?% spec :start pos) -1))
              current (aref spec pos))
        (unless (and seen-^ (char-equal current ?\}) (null args))
          (princ (substring spec last (1- pos))))
        (setq last pos pos (1+ pos))
        (cond
         ((char-equal current ?^)
          (incf last)
          (setq seen-^ t))
         ((char-equal current ?\n)
          (setq pos (position-if #'pp-non-whitep spec :start (1+ pos))
                last pos
                seen-^ nil))
         ((char-equal current ?\/)
          (let ((func-name
                 (substring spec pos
                            (position ?\/ spec :start pos))))
            (pp-call-func func-name (car args))
            (setq pos (+ 1 pos (length func-name))
                  last pos
                  seen-^ nil)))
         ((char-equal current ?\])
            (error "Unmatched condition termination directive"))
         ((char-equal current ?\[)
          (multiple-value-bind (new-pos new-args)
              (pp-condition (substring spec pos) args)
            (setq pos (+ pos new-pos) args new-args last pos)))
         ((char-equal current ?*)
            (setq args (cdr args) last (1+ last) seen-^ nil))
         ((char-equal current ?\{)
          (setq pos (+ pos (pp-list (substring spec pos) (car args)))
                args (cdr args)
                last pos
                seen-^ nil ))
         ((char-equal current ?\})
          (if args (setq pos 0 last 0)
            (throw 't nil)))
         ((char-equal current ?%)
          (setq seen-^ nil last (1+ last))
          (write-char ?%))
         (t (unless args (error "Not enough argumens for list iteration"))
            (setf (aref fstring 1) current)
            (princ (format fstring (car args)))
            (setq args (cdr args)
                  seen-^ nil
                  last
                  (1+ (or (position-if #'pp-directive-endp
                                         spec :start (1- pos))
                        (1- pos)))))))) pos))

(defun cl-format (spec &rest args)
  "Adds more format control options to the built-in `format'
function. The formatting tries to be similar to that of
Common Lisp, however it is lacking some features. None of
the added options accept modifiers. Grouping (the ~< ~> directives
is not implemented). No attempt is made to prevent recursive
printing. The indenting, except for `%\n' directive is
unaffected by any of the directives.
Following options are available:
  %{ spec %} - this directive will operate on a single argument
               the argument must be a list. The list is processed
               in the following way: at each iteration, N conses
               are taken from the list to satisfy the `spec' format
               specification. The content of these conses is
               then printed according to the `spec'.
  %[ choice-1 %; choice-2 %; ... choice-N %: default %]
             - this directive will look at the first argument, and
               if the argument is a number in range
               0 <= argument <= N, then the argument'th choice is
               printed according to the format specification of
               `choice-argument'. This directive will consume
               the argument if it could match it against the
               choice and as many arguments as is required to
               print the format spec. But, if the argument is not
               a number or is out of range, the default case triggers.
               Then, that argument and the following argument are
               printed according to the `default' format spec.
               For example:
               (cl-format \"%[pan%;%cup%:fruit-%]cake\")
               will print:
               \"fruit-cake\"
               and
               (cl-format \"%[pan%;%cup%:fruit-%]cake\" 1 ?c)
               will print:
               \"cupcake\"
  %*         - This directive instructs to skip the follwing argument.
  %^         - This directive is useful inside `%{ ... %}'
               directive. It will instruct to skip printing whatever
               text until the closing bracket, in case the argument's
               list was exhausted. For example:
               (cl-format \"%{ %s%^, %}\" '(1 2 3))
               will print: \"1, 2, 3\"
  %\\n       - I.e. percent sign followed by a newline character
               will instruct the printer to omit the linebreak and
               the white space which follows the directive until any
               non-white character is encountered.
  %/function/ - Allows calling a function named \"function\". The function
               will be called with one argument. The result of this function
               is printed into the string being constructed. Additionally,
               any printing function such as `print', `princ' or
               `write-char' etc. will print into the resulting string,
               so, for example:
               (cl-format \"%/identity\" 'x)
               will print:
               \"x\"
               and:
               (cl-format \"%/princ/\" 'x)
               will print:
               \"xx\"

Below is a contrieved example which is trying to exploit all features this
library provides:
 (cl-format \"begin: %{%s = %d%^,%}; %* %% %c %
             %% %{%{%[%s%;<%s>%:(%s)%]%^.%},%} %/identity/\"
            '(a 1 b 2 c 3) 42 ?\X '((0 a 1 b 2 c) (2 a 1 b 0 c)) 43)
Which prints:
\"begin: a = 1,b = 2,c = 3;  % X % a.<b>.(2).(c),(2).(a).<b>.c, 43\"
"
  (with-output-to-string
    (let ((pos 0) (last 0) (fstring "% ") current)
      (catch 't
        (while t
          (setq pos (1+ (or (position ?\% spec :start pos) -1))
                current (aref spec pos))
          (when (= pos 0) (throw 't nil))
          (princ (substring spec last (1- pos)))
          (setq last pos pos (1+ pos))
          (cond
           ((char-equal current ?^)
            (unless args
              (setq last (pp-if-nil spec)
                    pos last)))
           ((char-equal current ?\n)
            (setq pos (position-if #'pp-non-whitep spec :start pos)
                  last pos))
           ((char-equal current ?\/)
            (let ((func-name
                   (substring spec pos
                              (position ?\/ spec :start pos))))
              (pp-call-func func-name (car args))
              (setq pos (+ 1 pos (length func-name))
                    last pos)))
           ((char-equal current ?*)
            (setq args (cdr args) last (1+ last)))
           ((char-equal current ?\{)
            (setq pos (+ pos (pp-list (substring spec pos) (car args)))
                  args (cdr args)
                  last pos))
           ((char-equal current ?\})
            (error "Unmatched list iteration termination directive"))
           ((char-equal current ?\])
            (error "Unmatched condition termination directive"))
           ((char-equal current ?\[)
            (multiple-value-bind (new-pos new-args)
                (pp-condition (substring spec pos) args)
              (message "I have returned! %s %s" new-pos new-args)
              (setq pos (+ pos new-pos) args new-args last pos)))
           ((char-equal current ?%)
            (write-char ?%)
            (incf last))
           (t (unless args (error "Not enough argumens"))
              (setf (aref fstring 1) current)
              (princ (format fstring (car args)))
              (setq args (cdr args)
                    last 
                    (1+ (or (position-if #'pp-directive-endp
                                         spec :start (1- pos))
                        (1- pos)))))))))))

(provide 'formatting)

;;; formatting.el ends here.
